home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / emit.scm < prev    next >
Encoding:
Text File  |  1991-06-21  |  7.8 KB  |  263 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File emit.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Common Lisp code emission utilities
  5.  
  6. ; This is intimately tied up with the GENERATE module, but is
  7. ; separated for the purpose of producing alternate implementations of
  8. ; GENERATE with different internal calling conventions.  Thus GENERATE
  9. ; may know a lot about this module, but not vice versa.
  10.  
  11.  
  12. ; If @TARGET-PACKAGE is #f, leave unqualified program (top-level)
  13. ; variables in the SCHEME package.  Otherwise, intern them in the
  14. ; target package.
  15.  
  16. (define @target-package (make-fluid #f))
  17.  
  18.  
  19. ; @TRANSLATING-TO-FILE? This controls a number of inconsequential code
  20. ; generation decisions, e.g. whether the (IF #F X) should return
  21. ; unspecified and whether local variables should be turned into
  22. ; symbols in the target package.
  23.  
  24. (define @translating-to-file? (make-fluid #f))
  25.  
  26.  
  27. ; Program variable management:
  28.  
  29. (define (emit-program-variable-set! var CL-sym rhs-code)
  30.   (cond ((mutable-program-variable? var)
  31.      `(lisp:setq ,CL-sym ,rhs-code))
  32.     (else
  33.      `(schi:set!-aux
  34.        (lisp:quote ,(program-variable-name var))
  35.        ,rhs-code
  36.        (lisp:quote ,CL-sym)))))
  37.  
  38. ; SUBSTITUTE-AND-PEEP
  39. ; LISP:SUBLIS would suffice here, but this additionally does some
  40. ; peephole optimizations.  Careful -- this is semantically blind!
  41. ; In particular, never put lambda-bindings in SUBST-type definitions.
  42.  
  43. (define (substitute-and-peep alist cl-form)
  44.   (cond ((symbol? cl-form)
  45.      (let ((probe (assq cl-form alist)))
  46.        (if probe (cdr probe) cl-form)))
  47.     ((pair? cl-form)
  48.      (let ((yow (map (lambda (z) (substitute-and-peep alist z)) cl-form)))
  49.        (case (car yow)
  50.          ((lisp:funcall) (funcallify (cadr yow) (cddr yow)))
  51.          (else yow))))))
  52.  
  53. ; Dinky utilities
  54.  
  55. (define (insert-&rest l)
  56.   (if (null? (cdr l))
  57.       `(lisp:&rest ,@l)
  58.       (cons (car l) (insert-&rest (cdr l)))))
  59.  
  60. (define (cl-externalize-locals vars env)
  61.   (map (lambda (var)
  62.      (cl-externalize-local (local-variable-name var) env))
  63.        vars))
  64.  
  65. (define (cl-externalize-local name env)
  66.   (if (qualified-symbol? name)
  67.       ;; Don't touch local variables that aren't named by ordinary
  68.       ;; Scheme symbols.
  69.       name
  70.       (if (name-in-use? name env)
  71.       (in-target-package (make-name-from-uid name (generate-uid)))
  72.       (in-target-package (name->symbol name)))))
  73.  
  74. ; The lexical environment keeps track of which names are in use so that
  75. ; we can know when it's safe not to rename.
  76.  
  77. (define (generation-env free-vars) ;Initial environment
  78.   (map program-variable-name free-vars))
  79.  
  80. (define (bind-variables vars new-names env)
  81.   (for-each (lambda (var new-name)
  82.           (set-substitution! var new-name))
  83.         vars
  84.         new-names)
  85.   (gbind vars env))
  86.  
  87. (define (bind-functions vars new-names env)
  88.   (for-each (lambda (var new-name)
  89.           (set-substitution! var `(fun ,new-name)))
  90.         vars
  91.         new-names)
  92.   (gbind vars env))
  93.  
  94. (define (gbind vars env)
  95.   (append (map local-variable-name vars) env))
  96.  
  97. (define name-in-use? memq)
  98.  
  99. ; Kludge -- use it heuristically only!
  100.  
  101. (define (mutable-program-variable? var)
  102.   (let ((name (program-variable-name var)))
  103.     (and (not (qualified-symbol? name))
  104.      (let* ((s (symbol->string name))
  105.         (n (string-length s)))
  106.        (and (>= n 3)
  107.         (char=? (string-ref s 0) #\*)
  108.         (char=? (string-ref s (- n 1)) #\*))))))
  109.  
  110.  
  111. ; Package crud
  112.  
  113. (define (in-target-package sym)        ;For pretty output
  114.   (if (fluid @translating-to-file?)
  115.       (change-package sym (fluid @target-package))
  116.       sym))
  117.  
  118. (define (change-package sym package)
  119.   (if (and package (not (qualified-symbol? sym)))
  120.       (intern-renaming-perhaps (symbol->string sym) package)
  121.       sym))
  122.  
  123. ; Code emission utilities; peephole optimizers
  124.  
  125. (define (prognify form-list)
  126.   (if (null? (cdr form-list))
  127.       (car form-list)
  128.       `(lisp:progn ,@form-list)))
  129.  
  130. (define (deprognify cl-form)
  131.   (if (car-is? cl-form 'lisp:progn)
  132.       (cdr cl-form)
  133.       (list cl-form)))
  134.  
  135. (define (deandify cl-form)
  136.   (if (car-is? cl-form 'lisp:and)
  137.       (cdr cl-form)
  138.       (list cl-form)))
  139.  
  140. (define (deorify cl-form)
  141.   (if (car-is? cl-form 'lisp:or)
  142.       (cdr cl-form)
  143.       (list cl-form)))
  144.  
  145. (define (funcallify fun args)
  146.   (cond ((car-is? fun 'lisp:function)
  147.      ;; Peephole optimization
  148.      (let ((fun (cadr fun)))
  149.        (cond ((and (car-is? fun 'lisp:lambda)
  150.                (not (memq 'lisp:&rest (cadr fun)))
  151.                (= (length (cadr fun))
  152.               (length args)))
  153.           (letify (map list (cadr fun) args)
  154.               (prognify (cddr fun))))
  155.          (else
  156.           `(,fun ,@args)))))
  157.     (else
  158.      `(lisp:funcall ,fun ,@args))))
  159.  
  160. ;+++ To do: turn nested singleton LET's into LET*
  161.  
  162. (define (letify specs body)
  163.   (if (null? specs)
  164.       body
  165.       `(lisp:let ,specs ,@(deprognify body))))
  166.  
  167. (define (sharp-quote-lambda? exp)
  168.   (and (car-is? exp 'lisp:function)
  169.        (car-is? (cadr exp) 'lisp:lambda)))
  170.  
  171. ; The following hack has the express purpose of suppressing obnoxious
  172. ; warnings from losing Common Lisp compilers.  The problem would be
  173. ; mitigated if Common Lisp had some way to proclaim a variable to be
  174. ; lexical (or "not misspelled", as Moon calls it), AND if compilers treated
  175. ; variables like they did functions, permitting forward references.
  176.  
  177. (define @CL-variable-references (make-fluid 'dont-accumulate))
  178.  
  179. (define (noting-variable-references thunk)
  180.   (let-fluid @CL-variable-references '() thunk))
  181.  
  182. (define (locally-specialize form-list)
  183.   (let ((vars (fluid @CL-variable-references)))
  184.     (if (or (null? vars)
  185.         (and (pair? form-list)
  186.          (pair? (car form-list))
  187.          (memq (caar form-list)
  188.                '(lisp:defun lisp:defstruct lisp:deftype))))
  189.     form-list
  190.     `((lisp:locally (lisp:declare
  191.               (lisp:special ,@(map program-variable-CL-symbol
  192.                            vars)))
  193.         ,@form-list)))))
  194.  
  195. (define (emit-sharp-plus feature code)
  196.   (cond ((fluid @translating-to-file?)
  197.      `(,(make-photon
  198.          (lambda (port)
  199.            (display "#+" port)
  200.            (lisp:prin1 feature port)))
  201.        ,code))
  202.     ((memq feature lisp:*features*)
  203.      `(,code))
  204.     (else
  205.      `())))
  206.  
  207. (define (emit-top-level code)        ;form* -> form
  208.   (if (fluid @lambda-encountered?)
  209.       `(schi:at-top-level ,@code)
  210.       (prognify code)))
  211.  
  212. ; Continuation management
  213.  
  214. (define cont/value  '(cont/value))
  215. (define cont/return '(cont/return))
  216. (define cont/test   '(cont/test))
  217. (define cont/ignore '(cont/ignore))
  218.  
  219. (define continuation-type car)
  220.  
  221. (define (deliver-value-to-cont result-exp cont)
  222.   (case (continuation-type cont)
  223.     ((cont/value cont/ignore) result-exp)
  224.     ((cont/return) `(lisp:return ,result-exp)) ;not return-from?
  225.     ((cont/test) (value-form->test-form result-exp))
  226.     (else (error "unrecognized continuation" cont))))
  227.  
  228. ; For deliver-test-to-cont, we know that the value is either T or NIL.
  229. (define (deliver-test-to-cont test-exp cont)
  230.   (case (continuation-type cont)
  231.     ((cont/test cont/ignore) test-exp)
  232.     ((cont/return) `(lisp:return ,(test-form->value-form test-exp)))
  233.     ((cont/value) (test-form->value-form test-exp))
  234.     (else (error "unrecognized continuation" cont))))
  235.  
  236. (define (test-form->value-form cl-form)
  237.   `(schi:true? ,cl-form))
  238.       
  239. ; (truep (true? x)) is not equivalent to x in general, but as the result
  240. ; is being used as a test form, only its non-nilness matters.
  241. ; (truep (true? x))
  242. ;  == (not (eq (or x #f) #f))
  243. ;  == (not (eq (if x x #f) #f))
  244. ;  == (if x (not (eq x #f)) (not (eq #f #f)))
  245. ;  == (if x (not (eq x #f)) nil)
  246. ; so
  247. ; (if (truep (true? x)) y z)
  248. ;  == (if (if x (not (eq x #f)) x) y z)
  249. ;  == (if x (if (not (eq x #f)) y z) (if nil y z))
  250. ;  == (if x (if (eq x #f) z y) z)
  251. ;  == (if x y z)  whenever x is not #f.
  252. ; Now the result of calling test-form->value-form is never fed in as
  253. ; the argument to value-form->test-form, and the only other place a true?
  254. ; is introduced is by the primitives, and none of those can possibly pass
  255. ; #f as the argument to true?.  Therefore the transformation
  256. ; (truep (true? x)) => x  is safe for present purposes.
  257.  
  258. (define (value-form->test-form cl-form)
  259.   (cond ((car-is? cl-form 'schi:true?)
  260.      (cadr cl-form))
  261.     (else
  262.      `(schi:truep ,cl-form))))
  263.